perm filename ITMSBX.F4[MSS,LCS]1 blob
sn#091403 filedate 1974-03-19 generic text, type T, neo UTF8
00010 C**** ITMSUB, RNOTE ********
00100 C ********** WHOLE & HALF RESTS, BEAMS ******
00300 SUBROUTINE ITMSUB
00400 IMPLICIT INTEGER(A-Q,S-Z)
00500 REAL DIS,PWDS,DISX,HGT,POS,CENTR,STFF,HGT1
00600 COMMON/STF/RSTFAC(8),RSTJC/MIN/MINI,RMINI
00800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/BM/RA,RC,RJY
00900 COMMON/POSI/STFF(8),JJB,POS/PLTR/PLT,RHT,DIS
01100 EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJE,RJQ(3))
01200 1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
01300 1,(JK,JQ(9)),(JF,JQ(4)),(RJI,RJQ(7)),(RJH,RJQ(6))
01400 1 ,(RJG,RJQ(5)),(RJD,RJQ(2)),(RJI,RJQ(7)),(RJJ,RJQ(8))
01500 DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/
01600 RST7=RSTJC*7.
01700 RST18=RSTJC*18.
01750 C TO COMPENSATE FOR NOTE #3 COMING AT POS=0
01800
01900 RJBQ=JB
02000 JY=0
02100 IF(JA.EQ.9)GO TO 90
02250 IF(JA.EQ.10)GO TO 100
02275 C GO TO LINES, BEAMS, STAVES.
02300 C NEXT DRAWS STRAIGHT LINES
02400
02500 RD=RJD*RST7
02600 RA=0
02710 C WHY "*RSTJC"????
02755 RX=RTF+POS
02800 IF(JE.EQ.50)GO TO 300
02900 IF(RJF.GT.0)GO TO 401
03000 C FOR BAR LINES
03050 JA=44
03075 C CODE # IS CHNGD SO BAR LINES WON'T AFFECT MAX. HGT.
03100 IF(JG)GO TO 407
03110 IF(JG.EQ.0)JG=JD/100
03200 RX=RTF*RSTJC+POS
03250 L=MOD(JD,100)+JC+3
03300 C JD=401 MAKES 4X THICK BARLINE - ONE STAFF
03350 RY=STFF(L)+.5+RSTFAC(L)*58.
03400 RW=RY
03500 RJX=RJBQ
03700 42 CALL LINES(RJBQ,RX,3)
03800 IF(JG.EQ.-2)GO TO 404
03900 C IF JG<0 THEN WIGGLEY LINES ARE MADE.
04000 406 CALL LINES(RJX,RY,2)
04100 IF(JG.EQ.0)GO TO 43
04200 C FOR 'HEAVY' LINE.
04300 JG=JG-1
04400 RY=RW
04500 IF(MOD(JG,2).EQ.0)GO TO 406
04600 RY=RX
04700 RJX=RJX+1
04800 GO TO 406
05000 43 IF(RA.GT.0)GO TO 403
05100 RETURN
05200 C HOV IS RA.NE.0?
05300 C DRAWS BAR LINES. JD>0 CAUSES FULL LINE.
05400 403 RA=RA-3.72
05500 RJBQ=RJBQ+22
05600 RJX=RJX+22
05700 C DO ABOVE NEED *RSTJC? ************
05800 C **** BASED ON '596' ****
05900 GO TO 42
06000
06100 C FOR CRESC., DECRESC.
06200 300 RA=ABS(RJG/2.0)*RST7
06300 C AMOUNT OF SPREAD
06400 RJ=RJBQ
06600 RX=RX-RST18+RD
06610 IF(RJH.NE.0)GO TO 302
06620 C JUMP TO MAKE BOX
06690 RJF=RHORZ(RJF)
06700 IF(RJG)GO TO 301
06800 RJ=RJF
06900 RJF=RJBQ
07150 301 CALL LINX(RJ,RX+RA,RJF,RX)
07200 CALL LINES(RJ,RX-RA,2)
07300 C FOR CRESC, DECRESC: 4 POS1, STF, HGT, 50, POS1, +OR-N
07400 RETURN
07405
07410 302 RJH=RJH*RST7
07412 RJI=RJI*RST7
07415 IF(RJI.EQ.0)RJI=RJH
07420 RJB=RJBQ-RJH/2.
07430 RX=RX-RJI/2.
07440 C DRAWS BOX, CENTER IS IN MIDDLE
07445 C 4,POS,STF,NT#,50,0,0,,SIZ1[BY NT#S],SIZ2
07465 CALL LINX(RJB,RX,RJB+RJH,RX)
07470 CALL LINES(RJB+RJH,RX+RJI,2)
07480 CALL LINES(RJB,RX+RJI,2)
07490 CALL LINES(RJB,RX,2)
07495 RETURN
07500
07600 C DASHES
07610 401 POS=POS-RST18
07620 C********* 27/9/72 ******
07700 IF(JG.EQ.0)GO TO 407
07710 IF(ABS(RJF-RJB).LT..01)GO TO 402
07715 C VERTICAL DASHES IF P6=P2
07800 RA=RJF-RJB-4.
07900 RJF=RJB+2
08000 IF(JG.GT.0)JG=0
08010 GO TO 407
08020 402 RA=POS+RJE*RST7
08025 IF(RJH.EQ.0)RJH=.8
08027 C P8 CAN SET SIZE OF DASH
08030 RJ=RJH*RST7
08038 RX=RD+POS
08047 L=3
08048 K=2
08050 41 IF(RX.GT.RA)RETURN
08052 C DASHES MUST GO FROM BOTTOM TO TOP.
08055 CALL LINES(RJBQ,RX,L)
08060 RX=RX+RJ
08075 CALL EXCH(K,L)
08080 GO TO 41
08300 407 RX=RD+POS
08400 RY=RJE*RST7+POS
08500 IF(JG.EQ.-1)GO TO 408
08600 C FOR 'TR' JG=-2, 'ARPEGG' JG=-1
08700 RJX=IFIX(RHORZ(RJF))
08850 GO TO 42
08900 C DRAWS STRAIGHT LINES. ETC.
09000 404 L=(RA+4)/1.5
09100 RJ=RY
09200 DO 405 K=1,L
09300 CALL LINES(RJX,RJ,2)
09450 RJX=RJX+9
09500 C *RSTJC?
09800 405 CALL EXCH(RX,RJ)
09900 RETURN
10000
10100 408 IF(RX.GT.RY)CALL EXCH(RX,RY)
10500 RX=RX-12.*RSTJC
10550 RJ=6.*RSTJC
10600 RJX=4*RSTJC
10650 RW=RJBQ-RJX
10700 CALL LINES(RW,RX-RJ,3)
10800 410 CALL LINES(RJBQ+RJX,RX,2)
10900 CALL LINES(RW,RX+RJ,2)
11000 RX=RX+12.*RSTJC
11100 IF(RX.LT.RY)GO TO 410
11200 RETURN
11300 C VERTICAL WIGGLE
11400
11500
11600 C NEXT IS FOR BEAMS
11610 90 RMINI=RSTJC
11625 RX=2.7*RSTJC
11645 C******************************
11650 IF(JJ.LT.10)GO TO 91
11660 C NEXT FOR INNER, PARTIAL BEAMS
11670 RJJ=AMOD(RJJ,10.)
11675 GO TO(2,3,4),JJ/10
11680 2 RJH=RJI+RX
11685 GO TO 4
11690 3 RJH=RJI-RX
11697 C 10=SHORT PARTIAL LFT→RT., 20=RT.←LFT, 30=TO POS IN P8
11700 4 RH=RHORZ(RJH)
11705 C LEFT INNER POS.
11707 GO TO 1
11709 C******************************
11710 91 IF(JH.GE.0)GO TO 1
11730 92 RJI=RJB+RX
11740 IF(JH.LE.-20)RJI=RJF-RX
11750 192 JH=-JH
11760 IF(JJ.EQ.0)JJ=MOD(JH,10)
11762 JH=JH-JJ
11765 IF(JJ.EQ.0)JJ=1
11770 RJJ=JJ
11782 C IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
11800 1 IF(IABS(JD).LT.100)GO TO 97
11900 RMINI=.6*RSTJC
12100 RJE=AMOD(RJE,100.0)
12112 C SPACE BETWEEN BEAMS
12115 97 RJ=RMINI*11.
12120 RW=RMINI*RHGT
12122 C DIST. UP OR DOWN FROM NOTE HEAD.
12130 RJA=RJJ*RJ
12165 C DISPLACEMENT
12200 RD=RHORZ(ABS(RJI))
12250 C POSITION 3
12300 RJX=CENTR-RW+RJA
12400 C FINAL HEIGHT
12500 CC?????? RX=MOD(JG,10)-MOD(JH,10)
12550 RX=MOD(JG,10)
12600 JJB=JG-20
12700 RA=RHORZ(RJF)
12750 C HORIZANTAL DIST.
12800 RJY=RJE*RST7+POS-RST18-RW+RJA
12900 C************************
13010 RW=R14*RMINI
13100 IF(JG.GE.20)GO TO 93
13150 C JUMP IF STEMS ARE DOWN
13200 JJB=JG-10
13300 RJ=-RJ
13310 CCAUG.7,73 RJA=RMINI*R2HGT-2.*RJA-3.
13315 RY=-3
13317 IF(RMINI.LT..65)RY=-1
13320 RJA=RMINI*R2HGT-2.*RJA+RY
13400 RJX=RJX+RJA
13500 RJY=RJY+RJA
13600 RJBQ=RJBQ+RW
13650 C POSITION 1
13700 RA=RA+RW
13750 C POSITION 2
13800 RD=RD+RW
13810 C******************************
13820 RH=RH+RW
13900 93 IF(JJB.GT.RX)GO TO 94
13910 IF(JJ.GE.10)GO TO 7
14000 C**********************
14100 IF(JH.EQ.0)GO TO 94
14200 RJC=RW
14210 C******************************
14300 IF(RJI.EQ.0)GO TO 292
14400 IF(JH.GE.20)GO TO 193
14410 C******************************
14420 CC IF(JI.GT.0)GO TO 293
14500 293 RX=RJBQ-RD
14600 GO TO 194
14610 C******************************
14620 7 RHX=RH-RJBQ
14630 CC RJC=RX-RJBQ
14635 RJC=RD-RJBQ
14640 GO TO 292
14700 193 RX=RD-RA
14800 194 RJC=ABS(RX)
14900 292 DISX=ABS(RJBQ-RA)
15100 HGT=RJX-RJY
15110 IF(JJ.GE.10)HGT1=HGT*RHX/DISX
15200 C**********************
15300 RJC=RJC/DISX
15750 195 HGT=HGT*RJC
15800 196 L=JH/10
15900 JH=0
16000 IF(L.EQ.1)GO TO 95
16010 IF(JJ.GE.10)GO TO 8
16020 C***************
16100 C BEAM LFT=1, RT=2 (PARAM 8=10 OR 20)
16200 RJBQ=RD
16300 RJX=RJY+HGT
16400 GO TO 94
16410 C**************
16420 8 RJBQ=RH
16430 RA=RD
16440 RJY=RJX-HGT
16450 RJX=RJX-HGT1
16460 GO TO 94
16500 95 RA=RD
16600 RJY=RJX-HGT
16700 94 RC=0
16800 L=4
16900 IF(RMINI.LT..65)L=2
17000 CALL LINES(RJBQ,RJX,3)
17100 DO 941 K=1,L
17200 CALL BMS
17250 IF(PLT.GE.0)GO TO 940
17300 RC=RC+1
17400 CALL BMS
17500 CALL EXCH(RA,RJBQ)
17600 941 CALL EXCH(RJY,RJX)
17700 CALL BMS
18000 C DRAWS 5 LINES FOR BEAMS.
18100 940 JJB=JJB-1
18200 IF(JJB.LE.0)RETURN
18300 C IF P7=10 OR 20 ONE BEAM WILL APPEAR.
18400 RJY=RJY+RJ
18500 RJX=RJX+RJ
18600 GO TO 93
18700
18900 100 RA=0
19000 RJB=RHORZ(RJB)
19100 RJ=RHORZ(FLOAT(JD))
19200 IF(JD.EQ.0)RJ=596
19300 C FOR STAFF LINES: 10, POS 1, HGT(3 TO -3), 2ND POS., UP-DOWN(NT #S)
19310 JC=JC+4
19350 IF(RJF.EQ.0)RJF=RSTFAC(JC)
19400 IF(RJF.EQ.0)RJF=1.
19600 RSTFAC(JC)=RJF
19700 STFF(JC)=(JC-1)*123-369.+RJE*7.*RJF
19800 RX=STFF(JC)+RTF*RJF
19850 C FOR RTF SEE DATA
20150 C FOR 2 PASS PLOTTING
20800 RJF=RJF*14.
20900 DO 6 K=1,5
21000 RZ=RJ
21100 RW=RJB
21200 IF(K.EQ.2.OR.K.EQ.4)CALL EXCH(RW,RZ)
21650 CALL LINX(RZ,RX,RW,RX)
21700 6 RX=RX+RJF
21900 END
22000
22010 SUBROUTINE BMS
22020 COMMON/STF/RSTFAC(8),RSTJC/BM/RA,RC,RJY
22030 CALL LINES(RA,RJY+RC*RSTJC,2)
22040 END
22100
22200 SUBROUTINE METER
22600 COMMON /STF/RSTFAC(8),RSTJC
22700 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
23000 EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJD,RJQ(2))
23100 1,(RJF,RJQ(4)),(JF,JQ(4)),(RJE,RJQ(3)),(RJG,RJQ(5))
23200 1,(RJH,RJQ(6)),(RJG,RJQ(5))
23300
23400 C PARAMS 18 / POS / STF / TOP NUM/ BOT NUM/ VERT.HGT/ SIZE FAC.
23500
23600 KC=10.*RSTJC+JB
23700 JX=JB
23800 JA=5
23900 RJE=RJG
24000 IF(RJE.EQ.0)RJE=1.
24100 IF(JD.GT.9)GO TO 10
24200 IF(JE.GT.9)GO TO 20
24300 M=2
24400 JF=JD
24500 19 RJD=(8.+RJF)*RJE
24600 C MULTS BY SIZE FACTOR
24700 9 CALL NOTWRT
24800 GO TO (1,2,3,4,5),M
24900 1 RETURN
25000
25100 C ****** 4/(4) *****
25200 2 JF=JE
25300 M=1
25400 11 RJD=(4.+RJF)*RJE
25500 GO TO 9
25600
25700 C ******* (1)2/16 *******
25800 10 JF=JD/10
25900 M=3
26000 GO TO 19
26100
26200 C ****** 1(2)/16 *******
26300 3 M=4
26400 39 JB=JB+20.*RSTJC
26500 JF=MOD(JD,10)
26600 GO TO 9
26700
26800 4 IF(JE.LT.9)GO TO 30
26900 C ******** 12/(1)6 ******
27000 JB=JX
27100 JF=JE/10
27200 M=5
27300 GO TO 11
27400
27500 C ******* 12/1(6) ********
27600 5 JD=JE
27700 M=1
27800 GO TO 39
27900
28000 C ********* 12/(8) ********
28100 30 JB=KC
28200 GO TO 2
28300
28400 C ******** 4/16 *******
28500 20 M=4
28600 JB=KC
28700 JF=JD
28800 GO TO 19
28900 END
29000
29100 SUBROUTINE RNOTE(X)
29200 COMMON /PTR/PWDS(250),ITEM,L,I,IX/XRN/RN(4000)
29300 X=RN(IFIX(PWDS(IFIX(AMOD(X,1000.))))+2)
29400 END